home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / filebox.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  6.4 KB  |  252 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out Tk's "tk_getOpenFile" and
  2. # "tk_getSaveFile" commands. It is organized in the standard fashion
  3. # for Tcl tests.
  4. #
  5. # Copyright (c) 1996 Sun Microsystems, Inc.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. #
  10. # SCCS: @(#) filebox.test 1.4 97/04/30 16:00:15
  11. #
  12.  
  13. set tk_strictMotif_old $tk_strictMotif
  14.  
  15. #----------------------------------------------------------------------
  16. #
  17. # Procedures needed by this test file
  18. #
  19. #----------------------------------------------------------------------
  20.  
  21. proc ToPressButton {parent btn} {
  22.     global isNative
  23.     if {!$isNative} {
  24.     after 100 SendButtonPress $parent $btn mouse
  25.     }
  26. }
  27.  
  28. proc ToEnterFileByKey {parent fileName fileDir} {
  29.     global isNative
  30.     if {!$isNative} {
  31.     after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
  32.     }
  33. }
  34.  
  35. proc PressButton {btn} {
  36.     event generate $btn <Enter>
  37.     event generate $btn <1> -x 5 -y 5
  38.     event generate $btn <ButtonRelease-1> -x 5 -y 5
  39. }
  40.  
  41. proc EnterFileByKey {parent fileName fileDir} {
  42.     global tk_strictMotif
  43.     set w .__tk_filedialog
  44.     upvar #0 $w data
  45.  
  46.     if {$tk_strictMotif} {
  47.     $data(sEnt) delete 0 end
  48.     $data(sEnt) insert 0 [file join $fileDir $fileName]
  49.     } else {
  50.     $data(ent) delete 0 end
  51.     $data(ent) insert 0 $fileName
  52.     }
  53.  
  54.     update
  55.     SendButtonPress $parent ok mouse
  56. }
  57.  
  58. proc SendButtonPress {parent btn type} {
  59.     global tk_strictMotif
  60.     set w .__tk_filedialog
  61.     upvar #0 $w data
  62.  
  63.     set button $data($btn\Btn)
  64.     if ![winfo ismapped $button] {
  65.     update
  66.     }
  67.  
  68.     if {$type == "mouse"} {
  69.     PressButton $button
  70.     } else {
  71.     event generate $w <Enter>
  72.     focus $w
  73.     event generate $button <Enter>
  74.     event generate $w <KeyPress> -keysym Return
  75.     }
  76. }
  77.  
  78.  
  79. #----------------------------------------------------------------------
  80. #
  81. # The test suite proper
  82. #
  83. #----------------------------------------------------------------------
  84.  
  85. if {[string compare test [info procs test]] == 1} {
  86.     source defs
  87. }
  88.  
  89. if {$tcl_platform(platform) == "unix"} {
  90.     set modes "0 1"
  91. } else {
  92.     set modes 1
  93. }
  94.  
  95. set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}}
  96.  
  97. foreach mode $modes {
  98.  
  99.     #
  100.     # Test both the motif version and the "tk" version of the file dialog
  101.     # box on Unix.
  102.     #
  103.  
  104.     if {$tcl_platform(platform) == "unix"} {
  105.     set tk_strictMotif $mode
  106.     }
  107.  
  108.     #
  109.     # Test both the "open" and the "save" dialogs
  110.     #
  111.  
  112.     foreach command "tk_getOpenFile tk_getSaveFile" {
  113.  
  114.     test filebox-1.1 "$command command" {
  115.         list [catch {$command -foo} msg] $msg
  116.     } $unknownOptionsMsg
  117.  
  118.     regsub -all ,      $msg "" options
  119.     regsub \"-foo\" $options "" options
  120.  
  121.     foreach option $options {
  122.         if {[string index $option 0] == "-"} {
  123.         test filebox-1.2 "$command command" {
  124.             list [catch {$command $option} msg] $msg
  125.         } [list 1 "value for \"$option\" missing"]
  126.         }
  127.     }
  128.  
  129.     test filebox-1.3 "$command command" {
  130.         list [catch {$command -foo bar} msg] $msg
  131.     } $unknownOptionsMsg
  132.  
  133.     test filebox-1.4 "$command command" {
  134.         list [catch {$command -initialdir} msg] $msg
  135.     } {1 {value for "-initialdir" missing}}
  136.  
  137.     test filebox-1.5 "$command command" {
  138.         list [catch {$command -parent foo.bar} msg] $msg
  139.     } {1 {bad window path name "foo.bar"}}
  140.  
  141.     test filebox-1.6 "$command command" {
  142.         list [catch {$command -filetypes {Foo}} msg] $msg
  143.     } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
  144.  
  145.     if {[info commands tkMotifFDialog] == "" && [info commands tkFDialog] == ""} {
  146.         set isNative 1
  147.     } else {
  148.         set isNative 0
  149.     }
  150.  
  151.     if {$isNative && ![info exists INTERACTIVE]} {
  152.         continue
  153.     }
  154.  
  155.     set parent .
  156.  
  157.     set verylongstring longstring:
  158.     set verylongstring $verylongstring$verylongstring
  159.     set verylongstring $verylongstring$verylongstring
  160.     set verylongstring $verylongstring$verylongstring
  161.     set verylongstring $verylongstring$verylongstring
  162. #    set verylongstring $verylongstring$verylongstring
  163. #    set verylongstring $verylongstring$verylongstring
  164. #    set verylongstring $verylongstring$verylongstring
  165. #    set verylongstring $verylongstring$verylongstring
  166. #    set verylongstring $verylongstring$verylongstring
  167.  
  168.     set color #404040
  169.     test filebox-2.1 "$command command" {
  170.         ToPressButton $parent cancel
  171.         $command -title "Press Cancel ($verylongstring)" -parent $parent
  172.     } ""
  173.  
  174.  
  175.     if {$command == "tk_getSaveFile"} {
  176.         set fileName "12x 455"
  177.         set fileDir [pwd]
  178.         set pathName [file join [pwd] $fileName]
  179.     } else {
  180.         set thisFile [info script]
  181.         set fileName [file tail $thisFile]
  182.         set appPWD [pwd]
  183.         cd [file dirname $thisFile]
  184.         set fileDir [pwd]
  185.         cd $appPWD
  186.         set pathName [file join $fileDir $fileName]
  187.     }
  188.  
  189.     test filebox-2.2 "$command command" {
  190.         ToPressButton $parent ok
  191.         set choice [$command -title "Press Ok" \
  192.                 -parent $parent -initialfile $fileName -initialdir $fileDir]
  193.     } $pathName
  194.  
  195.     test filebox-2.3 "$command command" {
  196.         ToEnterFileByKey $parent $fileName $fileDir
  197.         set choice [$command -title "Enter \"$fileName\" and press Ok" \
  198.                 -parent $parent -initialdir $fileDir]
  199.     } $pathName
  200.  
  201.     set filters(1) {}
  202.  
  203.     set filters(2) {
  204.         {"Text files"    {.txt .doc}    }
  205.         {"Text files"    {}        TEXT}
  206.         {"Tcl Scripts"    {.tcl}        TEXT}
  207.         {"C Source Files"    {.c .h}        }
  208.         {"All Source Files"    {.tcl .c .h}    }
  209.         {"Image Files"    {.gif}        }
  210.         {"Image Files"    {.jpeg .jpg}    }
  211.         {"Image Files"    ""        {GIFF JPEG}}
  212.         {"All files"    *}
  213.     }
  214.  
  215.     set filters(3) {
  216.         {"Text files"    {.txt .doc}    TEXT}
  217.         {"Foo"        {""}        TEXT}
  218.     }
  219.  
  220.     foreach x [lsort -integer [array names filters]] {
  221.         test filebox-3.$x "$command command" {
  222.         ToPressButton $parent ok
  223.         set choice [$command -title "Press Ok" -filetypes $filters($x)\
  224.                 -parent $parent -initialfile $fileName -initialdir $fileDir]
  225.         } $pathName
  226.     }
  227.  
  228.     #
  229.     # The rest of the tests need to be executed on Unix only. The test whether
  230.     # the dialog box widgets were implemented correctly. These tests are not
  231.     # needed on the other platforms because they use native file dialogs.
  232.     #
  233.  
  234.  
  235.  
  236.  
  237.     # end inner if
  238.     }
  239.  
  240.     # end outer if
  241. }
  242.  
  243. set tk_strictMotif $tk_strictMotif_old
  244.  
  245. if {$isNative && ![info exists INTERACTIVE]} {
  246.     puts " Some tests were skipped because they could not be performed"
  247.     puts " automatically on this platform. If you wish to execute them"
  248.     puts " interactively, set the TCL variable INTERACTIVE and re-run"
  249.     puts " the test."
  250.     return
  251. }
  252.